home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 32 / advsys.zip / OBJECTS.ADI < prev    next >
Text File  |  1986-07-20  |  13KB  |  556 lines
  1. ; This is the object-oriented runtime package
  2. ; by David Betz
  3. ; July 19, 1986
  4.  
  5. ; ********************
  6. ; PROPERTY DEFINITIONS
  7. ; ********************
  8.  
  9. ; These properties will be used for connections between locations
  10. (property
  11.   north            ; the location to the north
  12.   south            ; the location to the south
  13.   east            ; the location to the east
  14.   west            ; the location to the west
  15.   up            ; the location above
  16.   down)            ; the location below
  17.  
  18. ; Basic object properties
  19. (property
  20.   initial-location    ; the initial location of a "thing"
  21.   description        ; the "long" description of a location
  22.   short-description)    ; the "short" description of a location
  23.  
  24. ; Connection properties
  25. (property
  26.   parent        ; the parent of an object
  27.   sibling        ; the next sibling of an object
  28.   child)        ; the first child of an object
  29.  
  30. ; Location properties
  31. (property
  32.   visited)        ; true if location has been visited by player
  33.  
  34. ; Portal properties
  35. (property
  36.   closed        ; true if the portal is closed
  37.   locked        ; true if the portal is locked
  38.   key            ; key to unlock the portal
  39.   other-side)        ; the other portal in a pair
  40.  
  41. ; **********************
  42. ; VOCABULARY DEFINITIONS
  43. ; **********************
  44.  
  45. ; Some abbreviations for common commands
  46. (synonym north n)
  47. (synonym south s)
  48. (synonym east e)
  49. (synonym west w)
  50. (synonym inventory i)
  51.  
  52. ; Define the basic vocabulary
  53. (conjunction and)
  54. (article the that)
  55.  
  56. ; ********************
  57. ; VARIABLE DEFINITIONS
  58. ; ********************
  59.  
  60. (variable
  61.   curloc        ; the location of the player character
  62.   %actor        ; the actor object
  63.   %dobject        ; the direct object
  64.   %iobject)        ; the indirect object
  65.  
  66. ; *********************
  67. ; CONNECTION PRIMITIVES
  68. ; *********************
  69.  
  70. ; Connect an object to a parent
  71. (define (connect p c)
  72.   (setp c parent p)
  73.   (setp c sibling (getp p child))
  74.   (setp p child c))
  75.  
  76. ; Connect all objects to their initial parents
  77. (define (connect-all &aux obj maxp1 par)
  78.   (setq obj 1)
  79.   (setq maxp1 (+ $ocount 1))
  80.   (while (< obj maxp1)
  81.     (if (setq par (getp obj initial-location))
  82.       (connect par obj))
  83.     (setq obj (+ obj 1))))
  84.  
  85. ; Disconnect an object from its current parent
  86. (define (disconnect obj &aux this prev)
  87.   (setq this (getp (getp obj parent) child))
  88.   (setq prev nil)
  89.   (while this
  90.     (if (= this obj)
  91.       (progn
  92.     (if prev
  93.       (setp prev sibling (getp this sibling))
  94.       (setp (getp this parent) child (getp this sibling)))
  95.     (setp this parent nil)
  96.     (return)))
  97.     (setq prev this)
  98.     (setq this (getp this sibling))))
  99.  
  100. ; Print the contents of an object (used by "look")
  101. (define (print-contents obj prop &aux desc)
  102.   (setq obj (getp obj child))
  103.   (while obj
  104.     (if (setq desc (getp obj prop))
  105.       (progn
  106.     (print " ")
  107.     (print desc)))
  108.     (setq obj (getp obj sibling))))
  109.  
  110. ; List the contents of an object (used for "inventory")
  111. (define (list-contents obj prop &aux desc)
  112.   (setq obj (getp obj child))
  113.   (while obj
  114.     (if (setq desc (getp obj prop))
  115.       (progn
  116.     (print "\t")
  117.     (print desc)
  118.     (terpri)))
  119.     (setq obj (getp obj sibling))))
  120.  
  121. ; ************************
  122. ; OBJECT CLASS DEFINITIONS
  123. ; ************************
  124.  
  125. ; ***********************
  126. ; The "basic-thing" class
  127. ; ***********************
  128.  
  129. (object basic-thing
  130.   (property
  131.     parent nil        ; the parent of this object
  132.     sibling nil))    ; the next sibling of this object
  133.  
  134. ; ***************************
  135. ; The "location" object class
  136. ; ***************************
  137.  
  138. (object location
  139.   (property
  140.     child nil        ; the first object in this location
  141.     visited nil)    ; has the player been here yet?
  142.   (method (knock? obj)
  143.     T)
  144.   (method (enter obj)
  145.     (connect self obj)
  146.     T)
  147.   (method (leave obj dir &aux loc)
  148.     (if (setq loc (getp self dir))
  149.       (if (send loc knock? obj)
  150.         (progn
  151.           (disconnect obj)
  152.           (send loc enter obj)))
  153.       (progn
  154.         (print "There is no exit in that direction.\n")
  155.         nil)))
  156.   (method (describe)
  157.     (if (getp self visited)
  158.       (print (getp self short-description))
  159.       (progn
  160.         (print (getp self description))
  161.         (print-contents self description)
  162.         (setp self visited t)))
  163.     (terpri)))
  164.  
  165.  
  166. ; ******************
  167. ; The "portal" class
  168. ; ******************
  169.  
  170. (basic-thing portal
  171.   (method (knock? obj)
  172.     (if (getp self closed)
  173.       (progn
  174.         (print "The ")
  175.         (print (getp self short-description))
  176.         (print " is closed!\n")
  177.         nil)
  178.       T))
  179.   (method (enter obj)
  180.     (connect (getp (getp self other-side) parent) obj))
  181.   (method (open)
  182.     (if (not (getp self closed))
  183.       (progn
  184.         (print "The ")
  185.         (print (getp self short-description))
  186.         (print " is already open!\n")
  187.         nil)
  188.       (if (getp self locked)
  189.         (progn
  190.           (print "The ")
  191.           (print (getp self short-description))
  192.           (print " is locked!\n")
  193.           nil)
  194.         (progn
  195.           (setp self closed nil)
  196.           T))))
  197.   (method (close)
  198.     (if (getp self closed)
  199.       (progn
  200.         (print "The ")
  201.         (print (getp self short-description))
  202.         (print " is already closed!\n")
  203.         nil)
  204.       (progn
  205.         (setp self closed T)
  206.         T)))
  207.   (method (lock thekey)
  208.     (if (not (getp self closed))
  209.       (progn
  210.         (print "The ")
  211.         (print (getp self short-description))
  212.         (print " is not closed!\n")
  213.         nil)
  214.       (if (getp self locked)
  215.         (progn
  216.           (print "The ")
  217.           (print (getp self short-description))
  218.           (print " is already locked!\n")
  219.           nil)
  220.         (if (not (= thekey (getp self key)))
  221.           (progn
  222.             (print "It doesn't fit the lock!\n")
  223.             nil)
  224.           (progn
  225.             (setp self locked t)
  226.             T)))))
  227.   (method (unlock thekey)
  228.     (if (not (getp self closed))
  229.       (progn
  230.         (print "The ")
  231.         (print (getp self short-description))
  232.         (print " is already open!\n")
  233.         nil)
  234.       (if (not (getp self locked))
  235.         (progn
  236.           (print "The ")
  237.           (print (getp self short-description))
  238.           (print " is not locked!\n")
  239.            nil)
  240.         (if (not (= thekey (getp self key)))
  241.           (progn
  242.             (print "It doesn't fit the lock!\n")
  243.             nil)
  244.           (progn
  245.             (setp self locked nil)
  246.             T))))))
  247.  
  248. ; *****************
  249. ; The "actor" class
  250. ; *****************
  251.  
  252. (basic-thing actor
  253.   (property
  254.     child nil)        ; the first "thing" carried by this actor
  255.   (method (move dir)
  256.     (send (getp self parent) leave self dir))
  257.   (method (take obj)
  258.     (disconnect obj)
  259.     (connect self obj))
  260.   (method (drop obj)
  261.     (disconnect obj)
  262.     (connect (getp self parent) obj))
  263.   (method (carrying? obj)
  264.     (= (getp obj parent) self))
  265.   (method (inventory)
  266.     (cond ((getp %actor child)
  267.            (print "You are carrying:\n")
  268.            (list-contents %actor short-description))
  269.           (T (print "You are empty-handed.\n")))))
  270.  
  271. ; *****************
  272. ; The "thing" class (things that can be taken)
  273. ; *****************
  274.  
  275. (basic-thing thing
  276.   (class-property
  277.     takeable t))
  278.  
  279. ; ****************************
  280. ; The "stationary-thing" class (things that can't be moved)
  281. ; ****************************
  282.  
  283. (basic-thing stationary-thing)
  284.  
  285. ; ***********************
  286. ; MISCELLANEOUS FUNCTIONS
  287. ; ***********************
  288.  
  289. ; Complain about a noun phrase
  290. (define (complain head n tail)
  291.   (print head)
  292.   (print-noun n)
  293.   (print tail)
  294.   (abort))
  295.  
  296. ; Find an object in a location
  297. (define (findobject loc n &aux this found)
  298.   (setq this (getp loc child))
  299.   (setq found nil)
  300.   (while this
  301.     (if (match this n)
  302.       (if found
  303.         (complain "I don't know which " n " you mean!\n")
  304.     (setq found this)))
  305.     (setq this (getp this sibling)))
  306.   found)
  307.  
  308. ; Find an object in the player's current location
  309. ;  (or in the player's inventory)
  310. (define (in-location n &aux obj)
  311.   (if (or (setq obj (findobject curloc n))
  312.           (setq obj (findobject %actor n)))
  313.     obj
  314.     (complain "I don't see a " n " here!\n")))
  315.  
  316. ; Find an object in the player's inventory
  317. ;  (or in the player's current location)
  318. (define (in-pocket n &aux obj)
  319.   (if (or (setq obj (findobject %actor n))
  320.           (setq obj (findobject curloc n)))
  321.     obj
  322.     (complain "You don't have a " n "!\n")))
  323.  
  324. ; ***************
  325. ; ACTION DEFAULTS
  326. ; ***************
  327.  
  328. (default
  329.   (actor optional))
  330.  
  331. ; ******************
  332. ; ACTION DEFINITIONS
  333. ; ******************
  334.  
  335. (action look
  336.   (verb look)
  337.   (code
  338.     (setp curloc visited nil)
  339.     (send curloc describe)))
  340.  
  341. (action a-take
  342.   (verb take get (pick up))
  343.   (direct-object)
  344.   (code
  345.     (setq %dobject (in-location $dobject))
  346.     (if (getp %dobject takeable)
  347.       (progn
  348.         (if (send %actor carrying? %dobject)
  349.           (complain "You are already carrying the " $dobject "!\n"))
  350.         (send %actor take %dobject)
  351.         (print-noun $dobject)
  352.         (print " taken.\n"))
  353.       (complain "You can't take the " $dobject "!\n"))))
  354.  
  355. (action take-err
  356.   (verb take get (pick up))
  357.   (code
  358.     (print "Take what?\n")))
  359.  
  360. (action a-drop
  361.   (verb drop (put down))
  362.   (direct-object)
  363.   (code
  364.     (setq %dobject (in-pocket $dobject))
  365.     (if (send %actor carrying? %dobject)
  366.       (progn
  367.         (send %actor drop %dobject)
  368.     (print-noun $dobject)
  369.     (print " dropped.\n"))
  370.       (complain "You aren't carrying the " $dobject "!\n"))))
  371.  
  372. (action drop-err
  373.   (verb drop (put down))
  374.   (code
  375.     (print "Drop what?\n")))
  376.  
  377. (action give
  378.   (verb give)
  379.   (direct-object)
  380.   (preposition to)
  381.   (indirect-object)
  382.   (code
  383.     (setq %dobject (in-pocket $dobject))
  384.     (setq %iobject (in-location $iobject))
  385.     (if (send %actor carrying? %dobject)
  386.       (progn
  387.         (send %actor drop %dobject)
  388.         (send %iobject take %dobject)
  389.     (print-noun $dobject)
  390.     (print " given.\n"))    
  391.       (complain "You aren't carrying the " $dobject "!\n"))))
  392.  
  393. (action give-err
  394.   (verb give)
  395.   (direct-object optional)
  396.   (code
  397.     (if $dobject
  398.       (complain "Give the " $dobject " to who?\n"))
  399.       (print "Give what?\n")))
  400.  
  401. (action a-inventory
  402.   (verb inventory)
  403.   (code
  404.     (send %actor inventory)))
  405.  
  406. ; ***************
  407. ; PORTAL COMMANDS
  408. ; ***************
  409.  
  410. (action a-open
  411.   (verb open)
  412.   (direct-object)
  413.   (code
  414.     (setq %dobject (in-location $dobject))
  415.     (send %dobject open)))
  416.  
  417. (action open-err
  418.   (verb open)
  419.   (code
  420.     (print "Open what?\n")))
  421.  
  422. (action a-close
  423.   (verb close)
  424.   (direct-object)
  425.   (code
  426.     (setq %dobject (in-location $dobject))
  427.     (send %dobject close)))
  428.  
  429. (action close-err
  430.   (verb close)
  431.   (code
  432.     (print "Close what?\n")))
  433.  
  434. (action a-lock
  435.   (verb lock)
  436.   (direct-object)
  437.   (preposition with)
  438.   (indirect-object)
  439.   (code
  440.     (setq %dobject (in-location $dobject))
  441.     (setq %iobject (in-pocket $iobject))
  442.     (send %dobject lock %iobject)))
  443.  
  444. (action lock-err
  445.   (verb lock)
  446.   (direct-object optional)
  447.   (code
  448.     (if $dobject
  449.       (complain "Lock the " $dobject " with what?\n"))
  450.       (print "Lock what?\n")))
  451.  
  452. (action a-unlock
  453.   (verb unlock)
  454.   (direct-object)
  455.   (preposition with)
  456.   (indirect-object)
  457.   (code
  458.     (setq %dobject (in-location $dobject))
  459.     (setq %iobject (in-pocket $iobject))
  460.     (send %dobject unlock %iobject)))
  461.  
  462. (action unlock-err
  463.   (verb unlock)
  464.   (direct-object optional)
  465.   (code
  466.     (if $dobject
  467.       (complain "Unlock the " $dobject " with what?\n"))
  468.       (print "Unlock what?\n")))
  469.  
  470. ; *********************
  471. ; GAME CONTROL COMMANDS
  472. ; *********************
  473.  
  474. (action save
  475.   (verb save)
  476.   (code
  477.     (save)))
  478.  
  479. (action restore
  480.   (verb restore)
  481.   (code
  482.     (restore)))
  483.  
  484. (action restart
  485.   (verb restart)
  486.   (code
  487.     (restart)))
  488.  
  489. (action quit
  490.   (verb quit)
  491.   (code
  492.     (print "Are you sure you want to quit? ")
  493.     (if (yes-or-no)
  494.       (exit))))
  495.  
  496. ; **************
  497. ; TRAVEL ACTIONS
  498. ; **************
  499.  
  500. (action go-north
  501.   (verb north (go north))
  502.   (code
  503.     (send %actor move north)))
  504.  
  505. (action go-south
  506.   (verb south (go south))
  507.   (code
  508.     (send %actor move south)))
  509.  
  510. (action go-east
  511.   (verb east (go east))
  512.   (code
  513.     (send %actor move east)))
  514.  
  515. (action go-west
  516.   (verb west (go west))
  517.   (code
  518.     (send %actor move west)))
  519.  
  520. (action go-up
  521.   (verb up (go up))
  522.   (code
  523.     (send %actor move up)))
  524.  
  525. (action go-down
  526.   (verb down (go down))
  527.   (code
  528.     (send %actor move down)))
  529.  
  530. ; *******************
  531. ; HANDLER DEFINITIONS
  532. ; *******************
  533.  
  534. (init
  535.   (connect-all)
  536.   (print welcome)
  537.   (setq curloc nil))
  538.  
  539. (update
  540.   (if (not (= (getp adventurer parent) curloc))
  541.     (progn
  542.       (setq curloc (getp adventurer parent))
  543.       (send curloc describe))))
  544.  
  545. (before
  546.   (setq %actor adventurer)
  547.   (if $actor
  548.     (progn
  549.       (setq %actor (in-location $actor))
  550.       (if (not (= (class %actor) actor))
  551.         (complain "You can't talk to a " $actor "!\n")))))
  552.  
  553.  
  554.  
  555.                                                                                                                              
  556.